Attribute VB_Name = "mResources"
'-----------------------------------------------------------------
'             PT DC Hub @ Direct Connect P2P Network
'-----------------------------------------------------------------
'       Developer: Carlos.DF (fLaSh) - Portugal
'          E-mail: carlosferreiracarlos@hotmail.com
' Project started: 10 - September - 2006
'         License: GNU General Public License.
'-----------------------------------------------------------------
'       Thanks to developers and contributores of SDCH/DDCH
'         The Left Hand, ButterflySoul, HaArD and Selyb
'  TheNOP, RollTheDice, JDommi, GhOstFaCE, ArchaicLight and TUFF
'-----------------------------------------------------------------
Option Explicit

Public Enum enuHighlighter
    VBScript = 0
    JScript = 1
    SQL = 2
    LUA = 3
End Enum

Public Enum enuXML
    EGLanguage = 0
    EGUsersMessages = 1
End Enum

Private Sub WriteBinary(ByRef strFileName As String, ByRef bytArray() As Byte)
1:   Dim lngFile As Long
2:   On Error GoTo Err
3:   If Not DEBUG_MODE Then
4:      lngFile = FreeFile
6:      Open strFileName For Binary Access Write As lngFile 'Open file
7:          Put lngFile, , bytArray  'Write array to file
8:      Close lngFile 'Close file
9:   End If
10:  Exit Sub
11:
Err:
12:  HandleError Err.Number, Err.Description, Erl & "|" & "mResources.WriteBinary(" & strFileName & ")"
End Sub

Public Function LoadImage(ByRef iID As Integer) As IPictureDisp
1:   On Error GoTo Err

3:   Set LoadImage = LoadResPicture(iID, vbResBitmap)

5:   Exit Function
6:
Err:
7:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.LoadImage(" & iID & ")"
End Function

Public Sub LoadAndSaveHighlighter(ByRef intType As enuHighlighter)
1:    Dim bytArray()  As Byte 'Byte array
2:    Dim lngFile     As Long
3:    Dim strFileName As String
4:    On Error GoTo Err

     'Load the resource into the byte array:
      Select Case intType
        Case enuHighlighter.VBScript
7:            bytArray = LoadResData(101, "Highlighter")
8:            strFileName = G_APPPATH & "\Settings\VB.bin"
        Case enuHighlighter.JScript
9:            bytArray = LoadResData(102, "Highlighter")
10:            strFileName = G_APPPATH & "\Settings\JScripts.bin"
        Case enuHighlighter.SQL
11:           bytArray = LoadResData(103, "Highlighter")
12:           strFileName = G_APPPATH & "\Settings\sql.bin"
        Case enuHighlighter.LUA
13:           bytArray = LoadResData(104, "Highlighter")
14:           strFileName = G_APPPATH & "\Settings\lua.bin"
15:   End Select

17:   WriteBinary strFileName, bytArray
        
19:   AddLog "Highlighter(" & intType & ") data loaded from resource and saved successfull."
    
21:   Exit Sub
22:
Err:
23: HandleError Err.Number, Err.Description, Erl & "|" & "mResources.LoadHighlighter(" & intType & ")"
End Sub

'IN DEV TEST..
Public Sub LoadAndSaveXML(ByRef intType As enuXML)
1:    Dim bytArray()  As Byte 'Byte array
2:    Dim strFileName As String
3:    On Error GoTo Err
        
      'Load the resource into the byte array:
      Select Case intType
          Case enuXML.EGLanguage
6:            bytArray = LoadResData(101, "XML")
7:            strFileName = G_APPPATH & "\Languages\English.xml"
          Case enuXML.EGUsersMessages
8:            bytArray = LoadResData(102, "XML")
9:            strFileName = G_APPPATH & "\Settings\UsersMessages.xml"
10:   End Select

12:   WriteBinary strFileName, bytArray

14:   AddLog "XML(" & intType & ") data loaded from resource and saved successfull."
    
16:   Exit Sub
17:
Err:
18:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.LoadAndSaveXML(" & intType & ")"
End Sub

Public Sub LoadAndSaveEmptyDB(Optional ByVal sPath As String = "")
1:    Dim bytArray()    As Byte
2:    Dim strFileName   As String
3:    Dim oZLib         As New clsZLib
4:    On Error GoTo Err
      'NOTE: the Empty DB is compressed in the resource file..
        
      'Load the resource into the byte array:
8:    bytArray = LoadResData(101, "DB")

10:   If sPath = "" Then
11:       strFileName = G_APPPATH & "\DBs\userdb.mdb"
12:   Else
13:       strFileName = sPath
14:   End If
    
16:   WriteBinary strFileName, bytArray
      
18:   oZLib.DecompressFile strFileName, strFileName
      
20:   Set oZLib = Nothing
      
22:   Exit Sub
23:
Err:
24:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.LoadAndSaveEmptyDB()"
End Sub

Public Sub LoadAndSaveScriptHelp()
1:    Dim bytArray()  As Byte
2:    Dim strFileName As String
3:    On Error GoTo Err
        
      'Load the resource into the byte array:
6:    bytArray = LoadResData(101, "TXT")
7:    strFileName = G_APPPATH & "\Settings\ScriptHelp.vbs"

9:    WriteBinary strFileName, bytArray
      
11:   Exit Sub
12:
Err:
13:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.LoadAndSaveEmptyDB()"
End Sub

#If LUA Then
Public Sub LoadLuaRegHKey()
1:    Dim bytArray()  As Byte
2:    Dim strFileName As String
3:    Dim srtData As String
4:    Dim strLib As String
5:    On Error GoTo Err
 
7:      strLib = G_APPPATH & "\NetLink.tlb"
8:      strLib = Replace(strLib, "/", "\")

10:     strFileName = G_APPPATH & "\Settings\LuaLink.reg"
 
12:     srtData = "Windows Registry Editor Version 5.00" & vbTwoLine
13:     srtData = srtData & "[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{7FFBB260-AA83-4064-B9EE-ACF11660BFC5}]" & vbNewLine
14:     srtData = srtData & "@=" & Chr(34) & "LuaLink" & Chr(34) & vbTwoLine
15:     srtData = srtData & "[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{7FFBB260-AA83-4064-B9EE-ACF11660BFC5}\Implemented Categories]" & vbTwoLine
16:     srtData = srtData & "[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{7FFBB260-AA83-4064-B9EE-ACF11660BFC5}\Implemented Categories\{62C8FE65-4EBB-45e7-B440-6E39B2CDBF29}]" & vbTwoLine
17:     srtData = srtData & "[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{7FFBB260-AA83-4064-B9EE-ACF11660BFC5}\InprocServer32]" & vbNewLine
18:     srtData = srtData & "@=" & Chr(34) & "mscoree.dll" & Chr(34) & vbNewLine
19:     srtData = srtData & Chr(34) & "ThreadingModel" & Chr(34) & "=" & Chr(34) & "Both" & Chr(34) & vbNewLine
20:     srtData = srtData & Chr(34) & "Class" & Chr(34) & "=" & Chr(34) & "LuaLink" & Chr(34) & vbNewLine
21:     srtData = srtData & Chr(34) & "Assembly" & Chr(34) & "=" & Chr(34) & "NetLink, Version=1.0.3414.23629, Culture=neutral, PublicKeyToken=null" & Chr(34) & vbNewLine
22:     srtData = srtData & Chr(34) & "RuntimeVersion" & Chr(34) & "=" & Chr(34) & "v2.0.50727" & Chr(34) & vbNewLine
23:     srtData = srtData & Chr(34) & "CodeBase" & Chr(34) & "=" & Chr(34) & "file:///" & strLib & Chr(34) & vbTwoLine
24:     srtData = srtData & "[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{7FFBB260-AA83-4064-B9EE-ACF11660BFC5}\InprocServer32\1.0.3414.23629]" & vbNewLine
25:     srtData = srtData & Chr(34) & "Class" & Chr(34) & "=" & Chr(34) & "LuaLink" & Chr(34) & vbNewLine
26:     srtData = srtData & Chr(34) & "Assembly" & Chr(34) & "=" & Chr(34) & "NetLink, Version=1.0.3414.23629, Culture=neutral, PublicKeyToken=null" & Chr(34) & vbNewLine
27:     srtData = srtData & Chr(34) & "RuntimeVersion" & Chr(34) & "=" & Chr(34) & "v2.0.50727" & Chr(34) & vbNewLine
28:     srtData = srtData & Chr(34) & "CodeBase" & Chr(34) & "=" & Chr(34) & "file:///" & strLib & Chr(34) & vbTwoLine
29:     srtData = srtData & "[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{7FFBB260-AA83-4064-B9EE-ACF11660BFC5}\ProgId]" & vbNewLine
30:     srtData = srtData & "@=" & Chr(34) & "LuaLink" & Chr(34) & vbTwoLine
 
32:     bytArray = UniStrToUTF8(srtData)
 
34:     WriteBinary strFileName, bytArray
 
        'Shell the HKey
37:     Shell "regedit /S " & """" & strFileName & """", vbHide
      
39:   Exit Sub
40:
Err:
41:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.LoadLuaRegHKey()"
End Sub
Private Function UniStrToUTF8(UniString) As Byte()
   ' Convert a Unicode string to a byte stream of UTF-8
2:   Dim BArray() As Byte
3:   Dim TempB() As Byte
4:   Dim i As Long
5:   Dim k As Long
6:   Dim TLen As Long
7:   Dim b1 As Byte
8:   Dim b2 As Byte
9:   Dim UTF16 As Long
10:   Dim j
11:   On Error GoTo Err
   
13:   TLen = Len(UniString)  ' Obtain length of Unicode input string
14:   If TLen = 0 Then Exit Function  ' get out if there's nothing to convert
15:   k = 0
16:   For i = 1 To TLen
      ' Work out the UTF16 value of the Unicode character
18:      CopyMemory b1, ByVal StrPtr(UniString) + ((i - 1) * 2), 1
19:      CopyMemory b2, ByVal StrPtr(UniString) + ((i - 1) * 2) + 1, 1
      ' Combine the 2 bytes into the Unicode UTF-16
21:      UTF16 = b2  ' assign b2 to UTF16 before multiplying by 256 to avoid overflow
22:      UTF16 = UTF16 * 256 + b1
      ' Convert UTF-16 to 2 or 3 bytes of UTF-8
24:      TempB = ToUTF8(UTF16)
      ' Copy the resultant bytes to BArray
26:      For j = 0 To UBound(TempB)
27:         ReDim Preserve BArray(k)
28:         BArray(k) = TempB(j): k = k + 1
29:      Next
30:      ReDim TempB(0)
31:   Next
32:   UniStrToUTF8 = BArray  ' Return the resultant UTF-8 byte array
33:   Exit Function
34:
Err:
35:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.UniStrToUTF8()"
End Function
Private Function ToUTF8(ByVal UTF16 As Long) As Byte()
1:    On Error GoTo Err
   ' Convert a 16bit UTF-16BE to 2 or 3 UTF-8 bytes
5:   Dim BArray() As Byte
6:   If UTF16 < &H80 Then
7:      ReDim BArray(0)  ' one byte UTF-8
8:      BArray(0) = UTF16  ' Use number as is
9:   ElseIf UTF16 < &H800 Then
10:      ReDim BArray(1)  ' two byte UTF-8
11:      BArray(1) = &H80 + (UTF16 And &H3F)  ' Least Significant 6 bits
12:      UTF16 = UTF16 \ &H40  ' Shift UTF16 number right 6 bits
13:      BArray(0) = &HC0 + (UTF16 And &H1F)  ' Use 5 remaining bits
14:   Else
15:      ReDim BArray(2)  ' three byte UTF-8
16:      BArray(2) = &H80 + (UTF16 And &H3F)  ' Least Significant 6 bits
17:      UTF16 = UTF16 \ &H40  ' Shift UTF16 number right 6 bits
18:      BArray(1) = &H80 + (UTF16 And &H3F)  ' Use next 6 bits
19:      UTF16 = UTF16 \ &H40  ' Shift UTF16 number right 6 bits again
20:      BArray(0) = &HE0 + (UTF16 And &HF)  ' Use 4 remaining bits
21:   End If
22:   ToUTF8 = BArray  ' Return UTF-8 bytes in an array
23:   Exit Function
24:
Err:
25:   HandleError Err.Number, Err.Description, Erl & "|" & "mResources.ToUTF8()"
End Function
#End If
